;;; Copyright © 2020 Maxime Devos <maxime.devos@student.kuleuven.be>
;;; This file is part of rehash.
;;;
;;; rehash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; rehash is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with rehash.  If not, see <http://www.gnu.org/licenses/>.

(define-module (test-utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (ice-9 format)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 textual-ports)
  #:use-module (ice-9 string-fun)
  #:use-module (rnrs bytevectors)
  #:use-module ((rnrs base) #:select (assert))
  #:use-module (system foreign)
  #:use-module (rehash configuration)
  #:use-module (rehash operations)
  #:use-module ((ice-9 control) #:select (let/ec))
  #:export (make-gnunet-setup
	    connect-rehash/test
	    test-group-with-cleanup/fibers
	    gnunet-setup-start!
	    gnunet-setup-stop!
	    gnunet-setup-exit!
	    check-time-format
	    almost-infinity))

(define make-tempdir
  (let* ((c:mkdtemp (dynamic-func "mkdtemp" (dynamic-link)))
	 (c:mkdtemp-proc (pointer->procedure '*
					     c:mkdtemp
					     '(*)
					     #:return-errno? #t)))
    (lambda (prefix)
      "Make a temporary directory, and return its filename"
      (let* ((tmpdir (or (getenv "TMPDIR")
			 (getenv "TMP")
			 "/tmp"))
	     (template (string-append tmpdir "/" prefix ".XXXXXX\0"))
	     ;; mutated in-place by c:mkdtemp-proc
	     (template-bv (string->utf8 template))
	     (result (c:mkdtemp-proc (bytevector->pointer template-bv))))
	;; TODO proper error messaging
	(assert (not (null-pointer? result)))
	(assert (equal? result (bytevector->pointer template-bv)))
	(let* ((as-a-string/nul (utf8->string template-bv)))
	  (substring/read-only as-a-string/nul
			       0
			       (1- (string-length as-a-string/nul))))))))

(define (delete-tempdir location)
  "Recursively delete the file at @var{location}"
  (format #t "Deleting temporary directory ~s~%" location)
  (define (enter? name stat result)
    ;; always descend
    #t)
  (define (leaf name stat result)
    (delete-file name)
    'ok)
  (define (down name stat result)
    'ok)
  (define (up name stat result)
    (rmdir name)
    'ok)
  (define (skip name stat resut)
    ;; some directory is unreadable
    (assert #f))
  (define (error name stat errno)
    (assert #f))

  (file-system-fold enter? leaf down up skip error 'ok location))

(define-record-type <gnunet-setup>
  (%make-gnunet-setup testcase directory started? config)
  gnunet-setup?
  (testcase  gnunet-setup-testcase)
  (directory gnunet-setup-directory set-gnunet-setup-directory!)
  (started?  gnunet-setup-started?  set-gnunet-setup-started!)
  (config    gnunet-setup-configuration set-gnunet-setup-configuration!))

(define (gnunet-setup-configuration-location setup)
  (string-append (gnunet-setup-directory setup)
		 "/gnunet.config"))

(define (make-gnunet-setup testcase)
  (%make-gnunet-setup testcase #f #f #f))

(define (gnunet-setup-initialize! setup)
  (unless (gnunet-setup-directory setup)
    (set-gnunet-setup-directory! setup (make-tempdir "rehashtest"))
    (format #t "The temporary directory for ~s is at ~s~%"
	    (gnunet-setup-testcase setup)
	    (gnunet-setup-directory setup))
    (set-gnunet-setup-configuration!
     setup (gnunet-test-configuration setup))))

(define (gnunet-setup-start! setup)
  (unless (gnunet-setup-directory setup)
    (gnunet-setup-initialize! setup))
  (unless (gnunet-setup-started? setup)
    ;; TODO don't daemonise
    (let ((status (system*
		   "gnunet-arm" "-c"
		   (gnunet-setup-configuration-location setup)
		   "--start")))
      ;; TODO more details
      (assert (= (status:exit-val status) 0)))
    (set-gnunet-setup-started! setup #t)))

;; TODO do this automatically when guile
;; exits abnormally
(define (gnunet-setup-stop! setup)
  (when (gnunet-setup-started? setup)
    (let ((status (system*
		   "gnunet-arm" "-c"
		   (gnunet-setup-configuration-location setup)
		   "-e")))
      (assert (= (status:exit-val status) 0)))
    (set-gnunet-setup-started! setup #f)))

(define (gnunet-setup-exit! setup)
  (when (gnunet-setup-started? setup)
    (gnunet-setup-stop! setup))
  (when (gnunet-setup-directory setup)
    (delete-tempdir (gnunet-setup-directory setup)))
  (set-gnunet-setup-configuration! setup #f))

(define (gnunet-test-configuration setup)
  (assert (not (string-any (string->char-set "$\n\r\t \0")
			   (gnunet-setup-directory setup))))
  (let* ((configuration-using-tmpdir
	  (call-with-input-file "scheme-tests/nonetconf.conf"
	    (lambda (in)
	      (get-string-all in))))
	 (fixed-configuration
	  (string-replace-substring configuration-using-tmpdir
				    "$GNUNET_TMP"
				    (gnunet-setup-directory setup)))
	 (where (gnunet-setup-configuration-location setup))
	 (config-port (open-file where "w"
				 #:encoding "UTF-8")))
    (put-string config-port fixed-configuration)
    (close-port config-port)
    (load-configuration where)))

(define (connect-rehash/test setup)
  (gnunet-setup-initialize! setup)
  (connect-rehash (gnunet-setup-configuration setup)))

(define almost-infinity
  (- (expt 2 64) 1))

(define (needs-timeformat-upgrade?)
  (> (/ (current-time) internal-time-units-per-second)
     (/ (expt 2 63) #e1e6))) ;; #e1e6: microseconds in a second

(define (check-time-format)
  (if (needs-timeformat-upgrade?)
      (begin
	(format (current-error-port)
		"Warning: at least 292 millenia since the Unix epoch have\
passed!~%Please upgrade time types in:~%\
* GNUnet~%\
* guile-gnunet~%\
* guile-fibers~%\
* guile~%\
* libc~%\
* the kernel~%\
where required.~%")
	#f)
      #t))

;; FIXME the name is somewhat misleading,
;; as this does not actually create a srfi-63 test group.
;;
;; Delimit the stack for a more relevant backtrace.
;; (And for avoiding exceptions when printing backtraces.
;; Not sure what's going on there.)
(define-syntax test-group-with-cleanup/fibers
  (syntax-rules ()
    ((_ exp exp* ... cleanup)
     ((let/ec ec
	(with-exception-handler
	    (lambda (ex)
	      ;; Warning: this is executed in the dynamic context
	      ;; of the code that raised the exception, so current-output-port
	      ;; and current-error-port should not be anything particularily
	      ;; important. (This is the case in the tests.)
	      (backtrace)
	      (write ex)
	      (newline)
	      (ec (lambda ()
		    cleanup
		    (raise-exception ex))))
	  (lambda ()
	    (start-stack 'test-group
			 (call-with-values (lambda () exp exp* ...)
			   (lambda ret
			     (ec (lambda ()
				   cleanup
				   (apply values ret)))))))
	  ;; to preserve backtraces
	  #:unwind? #f))))))
